home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / EXTEND.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  12.5 KB  |  358 lines
  1. ; EXTEND.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            EXTEND-SYNTAX support                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Kent Dybvig        Date: 1986            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ; Copyright (c) 1986 R. Kent Dybvig
  23. ; Permission to copy this software, in whole or in part, to use this
  24. ; software for any lawful purpose, and to redistribute this software
  25. ; is granted subject to the restriction that all copies made of this 
  26. ; software must include this copyright notice in full.
  27. ;  
  28. ; EXTEND-SYNTAX is a syntax extension facility based on pattern match-
  29. ; ing. The extend-syntax code presented here was contributed by R. Kent
  30. ; Dybvig, as implemented for Chez Scheme and described in his book,
  31. ; The Scheme Programming Language. The code has been modified to run 
  32. ; under TI Scheme.
  33. ;
  34. ; Methods similar to extend-syntax exist in most implementations of 
  35. ; Scheme, including TI Scheme's own SYNTAX special form. EXTEND-SYNTAX
  36. ; however, is much more powerful in its capabilities than SYNTAX. A full
  37. ; description of extend-syntax is beyond the scope of this documentation.
  38. ; Other than some examples I will list here, I must refer you to Kent's 
  39. ; book or other documents for further information on EXTEND-SYNTAX. For 
  40. ; those of you already familiar with extend-syntax, its basic syntax is:
  41. ;
  42. ;  (extend-syntax (name key ...) (pattern optional-fender expansion) ...)
  43. ;
  44. ; Examples:
  45. ;
  46. ;     (extend-syntax (when)             
  47. ;       ((when test exp1 exp2 ...)         
  48. ;       (if test (begin exp1 exp2 ...) #F)))
  49. ;
  50. ;     (extend-syntax (let)
  51. ;      ((let ((x v) ...) e1 e2 ...)
  52. ;       ((lambda (x ...) e1 e2 ...) v ...)))
  53. ;
  54. ;
  55. ;  NOTE - You may use EXPAND to see an expansion of an extend-syntax
  56. ;         definition. See the READ.ME file for explanation of EXPAND.
  57. ;
  58.  
  59.  
  60. (macro unless 
  61.    (lambda (e) 
  62.       (append (list 'when (list 'not (cadr e))) (cddr e))))
  63.  
  64. (define-structure %%boxed-obj value)
  65.  
  66. (define box (lambda (objct) (make-%%boxed-obj 'value objct)))
  67.  
  68. (define unbox (lambda (box) (if (%%boxed-obj? box)
  69.                 (%%boxed-obj-value box)
  70.                 (error "Object referenced is not a BOX" box))))
  71.  
  72. (define set-box! (lambda (box objct)
  73.            (if (%%boxed-obj? box)
  74.                (set! (%%boxed-obj-value box) objct)
  75.                (error "Object to be set is not a BOX" box))))
  76.  
  77.  
  78. (define %%map2
  79.   (lambda (f a1 a2)
  80.     (let loop ((result ())
  81.            (a1 a1)
  82.            (a2 a2))
  83.       (if (null? a1)
  84.       (%reverse! result)
  85.       (loop (cons (f (car a1) (car a2)) result)
  86.         (cdr a1)
  87.         (cdr a2))))))
  88.  
  89. (macro %%multi-mapper
  90.   (lambda (x)
  91.     (cond ((syntax-match? '(%%multi-mapper) '(%%multi-mapper f a1 ...) x)
  92.        (let ((g10 (map (lambda (x) (gensym))
  93.                (cddr x))))
  94.          (quasiquote (let loop ((result ())
  95.                     (unquote-splicing
  96.                      (%%map2  (lambda (g9 g11)
  97.                         (quasiquote ((unquote g11) 
  98.                                  (unquote g9))))
  99.                           (cddr X) g10)))
  100.                (if (or (unquote-splicing
  101.                     (map (lambda (g11)
  102.                        (quasiquote 
  103.                           (null? (car (unquote g11)))))
  104.                      g10)))
  105.                    (%reverse! result)
  106.                    (loop (cons ((unquote (cadr x))
  107.                         (unquote-splicing
  108.                          (map (lambda (g11)
  109.                             (quasiquote 
  110.                             (car (unquote g11))))
  111.                           g10)))
  112.                        result)
  113.                      (unquote-splicing
  114.                       (map (lambda (g11)
  115.                          (quasiquote (cdr (unquote g11))))
  116.                        g10))))))))
  117.       (else (error "%%MULTI-MAPPER: invalid syntax " x)))))
  118.  
  119.  
  120. (define %%make-syntax 
  121.  (letrec
  122.    ((id-name car)
  123.     (id (lambda (name accessor control) (list name accessor control)))
  124.     (id-accessor cadr)
  125.     (id-control caddr)
  126.     (loop (lambda () (box '())))
  127.     (loop-ids unbox)
  128.     (loop-ids! set-box!)
  129.     (c...rs
  130.        `((car caar . cdar)
  131.          (cdr cadr . cddr)
  132.          (caar caaar . cdaar)
  133.          (cadr caadr . cdadr)
  134.          (cdar cadar . cddar)
  135.          (cddr caddr . cdddr)
  136.          (caaar caaaar . cdaaar)
  137.          (caadr caaadr . cdaadr)
  138.          (cadar caadar . cdadar)
  139.          (caddr caaddr . cdaddr)
  140.          (cdaar cadaar . cddaar)
  141.          (cdadr cadadr . cddadr)
  142.          (cddar caddar . cdddar)
  143.          (cdddr cadddr . cddddr)))
  144.     (add-car
  145.        (lambda (accessor)
  146.           (let ((x (and (pair? accessor) (assq (car accessor) c...rs))))
  147.              (if (null? x)
  148.                  `(car ,accessor)
  149.                  `(,(cadr x) ,@(cdr accessor))))))
  150.     (add-cdr
  151.        (lambda (accessor)
  152.           (let ((x (and (pair? accessor) (assq (car accessor) c...rs))))
  153.              (if (null? x)
  154.                  `(cdr ,accessor)
  155.                  `(,(cddr x) ,@(cdr accessor))))))
  156.     (parse
  157.        (lambda (keys pat acc cntl)
  158.           (cond
  159.              ((symbol? pat)
  160.               (if (memq pat keys)
  161.                   '()
  162.                   (list (id pat acc cntl))))
  163.              ((pair? pat)
  164.               (if (equal? (cdr pat) '(...))
  165.                   (let ((x (gensym)))
  166.                      (parse keys (car pat) x (id x acc cntl)))
  167.                   (append (parse keys (car pat) (add-car acc) cntl)
  168.                           (parse keys (cdr pat) (add-cdr acc) cntl))))
  169.              (else '()))))
  170.  
  171.     (gen
  172.        (lambda (exp ids loops)
  173.           (cond
  174.              ((symbol? exp)
  175.               (let ((id (lookup exp ids)))
  176.                  (if (null? id)
  177.                      exp
  178.                      (begin
  179.                         (add-control! (id-control id) loops)
  180.                         (list 'unquote (id-accessor id))))))
  181.              ((pair? exp)
  182.               (cond
  183.                  ((eq? (car exp) 'with)
  184.                   (unless (syntax-match? '(with) '(with ((p x) ...) e ...) exp)
  185.                      (error  "EXTEND-SYNTAX: invalid 'with' form" exp))
  186.                   (list 'unquote
  187.                      (gen-with
  188.                         (map car (cadr exp))
  189.                         (map cadr (cadr exp))
  190.                         (caddr exp)
  191.                         ids
  192.                         loops)))
  193.                  ((and (pair? (cdr exp)) (eq? (cadr exp) '...))
  194.                   (let ((x (loop)))
  195.                      (make-loop
  196.                         x
  197.                         (gen (car exp) ids (cons x loops))
  198.                         (gen (cddr exp) ids loops))))
  199.                  (else
  200.                   (let ((a (gen (car exp) ids loops))
  201.                         (d (gen (cdr exp) ids loops)))
  202.                      (if (and (pair? d) (eq? (car d) 'unquote))
  203.                          (list a (list 'unquote-splicing (cadr d)))
  204.                          (cons a d))))))
  205.              (else exp))))
  206.  
  207.     (gen-with
  208.        (lambda (pats exps body ids loops)
  209.           (if (null? pats)
  210.               (make-quasi (gen body ids loops))
  211.               (let ((p (car pats)) (e (car exps)) (g (gensym)))
  212.                  `(let ((,g ,(gen-quotes e ids loops)))
  213.                      ,(gen-with
  214.                          (cdr pats)
  215.                          (cdr exps)
  216.                          body
  217.                          (append (parse '() p g '()) ids)
  218.                          loops))))))
  219.  
  220.     (gen-quotes
  221.        (lambda (exp ids loops)
  222.           (cond
  223.              ((syntax-match? '(quote) '(quote x) exp)
  224.               (make-quasi (gen (cadr exp) ids loops)))
  225.              ((pair? exp)
  226.               (cons (gen-quotes (car exp) ids loops)
  227.                     (gen-quotes (cdr exp) ids loops)))
  228.              (else exp))))
  229.  
  230.     (lookup
  231.        (lambda (sym ids)
  232.           (let ((x (mem (lambda (x) (eq? (id-name x) sym)) ids)))
  233.               (and x (car x)))))
  234.  
  235.     (add-control!
  236.        (lambda (id loops)
  237.           (unless (null? id)
  238.              (when (null? loops)
  239.                 (error "EXTEND-SYNTAX: missing ellipsis in expansion"))
  240.              (let ((x (loop-ids (car loops))))
  241.                 (unless (memq id x)
  242.                    (loop-ids! (car loops) (cons id x))))
  243.              (add-control! (id-control id) (cdr loops)))))
  244.  
  245.     (make-loop
  246.        (lambda (loop body tail)
  247.           (let ((ids (loop-ids loop)))
  248.              (when (null? ids)
  249.                 (error "EXTEND-SYNTAX: extra ellipsis in expansion"))
  250.              (cond
  251.                 ((equal? body (list 'unquote (id-name (car ids))))
  252.                  (if (null? tail)
  253.                      (list 'unquote (id-accessor (car ids)))
  254.                      (cons (list 'unquote-splicing (id-accessor (car ids)))
  255.                            tail)))
  256.                 ((and (null? (cdr ids))
  257.                       (syntax-match? '(unquote) '(unquote (f x)) body)
  258.                       (eq? (cadadr body) (id-name (car ids))))
  259.                  (let ((x `(%%multi-mapper ,(caadr body) ,(id-accessor (car ids)))))
  260.                     (if (null? tail)
  261.                         (list 'unquote x)
  262.                         (cons (list 'unquote-splicing x) tail))))
  263.                 (else
  264.                  (let ((x `(%%multi-mapper (lambda ,(map id-name ids) ,(make-quasi body))
  265.                                 ,@(map id-accessor ids))))
  266.                     (if (null? tail)
  267.                         (list 'unquote x)
  268.                         (cons (list 'unquote-splicing x) tail))))))))
  269.  
  270.     (make-quasi
  271.        (lambda (exp)
  272.           (if (and (pair? exp) (eq? (car exp) 'unquote))
  273.               (cadr exp)
  274.               (list 'quasiquote exp))))
  275.     
  276.     (make-clause
  277.        (lambda (ks cl x)
  278.           (cond
  279.              ((syntax-match? '() '(pat fender exp) cl)
  280.               (let ((pat (car cl)) (fender (cadr cl)) (exp (caddr cl)))
  281.                  (let ((ids (parse ks pat x '())))
  282.                     `((and (syntax-match? ',ks ',pat ,x)
  283.                            ,(gen-quotes fender ids '()))
  284.                       ,(make-quasi (gen exp ids '()))))))
  285.              ((syntax-match? '() '(pat exp) cl)
  286.               (let ((pat (car cl)) (exp (cadr cl)))
  287.                 (let ((ids (parse ks pat x '() )))
  288.                     `((syntax-match? ',ks ',pat ,x)
  289.                       ,(make-quasi (gen exp ids '()))))))
  290.              (else
  291.               (error  "EXTEND-SYNTAX: invalid clause" cl)))))
  292.     (make-syntaxer
  293.        (let ((x (string->uninterned-symbol "x")))
  294.           (lambda (keys clauses)
  295.              `(lambda (,x)
  296.                  (cond
  297.           ,@(map (lambda (cl)
  298.                (make-clause keys cl x)) clauses)
  299.             (else
  300.              (error (string-append (symbol->string ',(car keys))
  301.                        ": invalid syntax") ,x))))))))
  302.    make-syntaxer))
  303.  
  304. (define mem
  305.   (lambda (f alist)
  306.     (let loop ((l alist))
  307.       (if (null? l)
  308.       '()
  309.       (if (f (car l))
  310.           l
  311.           (loop (cdr l)))))))
  312.  
  313. ;  (define-syntax-expander extend-syntax              ;Original code in body of letrec
  314. ;     (lambda (x e)
  315. ;        (let ((keys (cadr x)) (clauses (cddr x)))
  316. ;           (e `(define-syntax-expander ,(car keys)
  317. ;                  ,(make-syntax keys clauses))))))
  318.  
  319.  
  320.  
  321. (macro extend-syntax
  322.  (lambda (x)
  323.     (let ((keys (cadr x))
  324.       (clauses (cddr x)))
  325.       `(macro ,(car keys) ,(%%make-syntax keys clauses)))))
  326.  
  327.  
  328. ;   (define-syntax-expander extend-syntax/code         ;original code in body of letrec
  329. ;      (lambda (x e)
  330. ;         (let ((keys (cadr x)) (clauses (cddr x)))
  331. ;            `',(make-syntax keys clauses)))))
  332.  
  333. (macro extend-syntax/code
  334.   (lambda (x)
  335.     (let ((keys (cadr x)) (clauses (cddr x)))
  336.      `',(%%make-syntax keys clauses))))
  337.  
  338. ; syntax-match? is used by extend-syntax to choose among clauses and
  339. ; to check for syntactic errors.  It is also available to the user.
  340.  
  341. (define syntax-match?
  342.    (lambda (keys pat exp)
  343.       (cond
  344.          ((symbol? pat) (if (memq pat keys) (eq? exp pat) #T))
  345.          ((pair? pat)
  346.           (if (equal? (cdr pat) '(...))
  347.               (let f ((lst exp))
  348.                  (or (null? lst)
  349.                      (and (pair? lst)
  350.                           (syntax-match? keys (car pat) (car lst))
  351.                           (f (cdr lst)))))
  352.               (and (pair? exp)
  353.                    (syntax-match? keys (car pat) (car exp))
  354.                    (syntax-match? keys (cdr pat) (cdr exp)))))
  355.          (else (equal? exp pat)))))
  356.  
  357.  
  358.